Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/operat_1/picmask.frm

Visual Basic Form | 1999-08-25 | 23.7 KB | 638 lines

VERSION 5.00
Begin VB.Form frmPicMask
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Mask, transparency and raster operations"
   ClientHeight    =   5595
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6645
   Icon            =   "picmask.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   373
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   443
   Begin VB.CommandButton cmdClear
      Caption         =   "Clear"
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   3300
      TabIndex        =   19
      ToolTipText     =   "Use only one API, via reverse masked foreground"
      Top             =   4830
      Width           =   1020
   End
   Begin VB.CommandButton cmdExit
      Caption         =   "Exit"
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   4350
      TabIndex        =   18
      Top             =   4830
      Width           =   1020
   End
   Begin VB.PictureBox picTransparent
      AutoRedraw      =   -1  'True
      Height          =   1575
      Left            =   4650
      ScaleHeight     =   101
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   102
      TabIndex        =   17
      Top             =   2910
      Width           =   1590
   End
   Begin VB.PictureBox picFgd
      AutoRedraw      =   -1  'True
      Height          =   1545
      Left            =   2490
      Picture         =   "picmask.frx":030A
      ScaleHeight     =   99
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   102
      TabIndex        =   16
      Top             =   630
      Width           =   1590
   End
   Begin VB.CommandButton cmdMethod2
      Caption         =   "Method 2"
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   2250
      TabIndex        =   14
      ToolTipText     =   "Involve many APIs and DCs, via transparent bitmap"
      Top             =   4830
      Width           =   1020
   End
   Begin VB.PictureBox picReverseMaskedFgd
      AutoRedraw      =   -1  'True
      Height          =   1545
      Left            =   4650
      ScaleHeight     =   99
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   104
      TabIndex        =   5
      Top             =   2910
      Width           =   1620
   End
   Begin VB.CommandButton cmdMethod1
      Caption         =   "Method 1"
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   1200
      TabIndex        =   4
      ToolTipText     =   "Use only one API, via reverse masked foreground"
      Top             =   4830
      Width           =   1020
   End
   Begin VB.PictureBox picProduct
      AutoRedraw      =   -1  'True
      Height          =   1575
      Left            =   4710
      ScaleHeight     =   101
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   102
      TabIndex        =   3
      Top             =   630
      Width           =   1590
   End
   Begin VB.PictureBox picReversedMask
      AutoRedraw      =   -1  'True
      Height          =   1515
      Left            =   2520
      ScaleHeight     =   97
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   98
      TabIndex        =   2
      Top             =   2910
      Width           =   1530
   End
   Begin VB.PictureBox picMask
      AutoRedraw      =   -1  'True
      Height          =   1575
      Left            =   270
      ScaleHeight     =   101
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   102
      TabIndex        =   1
      Top             =   2880
      Width           =   1590
   End
   Begin VB.PictureBox picBackgd
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   1650
      Left            =   270
      Picture         =   "picmask.frx":7FFC
      ScaleHeight     =   106
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   102
      TabIndex        =   0
      Top             =   630
      Width           =   1590
   End
   Begin VB.PictureBox picUnblockedFgd
      AutoRedraw      =   -1  'True
      Height          =   1545
      Left            =   2520
      ScaleHeight     =   99
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   99
      TabIndex        =   15
      Top             =   2910
      Width           =   1545
   End
   Begin VB.Label lblEqual
      Caption         =   "="
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   13.5
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   315
      Left            =   4290
      TabIndex        =   13
      Top             =   1170
      Width           =   225
   End
   Begin VB.Label lblPlus
      Caption         =   "+"
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   13.5
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   315
      Left            =   2040
      TabIndex        =   12
      Top             =   1200
      Width           =   225
   End
   Begin VB.Label lblEndResult
      Alignment       =   2  'Center
      Caption         =   "Product"
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   4860
      TabIndex        =   11
      Top             =   240
      Width           =   1380
   End
   Begin VB.Label lblReversedMask
      Alignment       =   2  'Center
      Caption         =   "Reversed mask"
      Height          =   375
      Left            =   2670
      TabIndex        =   10
      Top             =   2460
      Width           =   1230
   End
   Begin VB.Label lblReverseMaskedFgd
      Alignment       =   2  'Center
      Caption         =   "Reverse-masked foreground"
      Height          =   405
      Left            =   4800
      TabIndex        =   9
      Top             =   2460
      Width           =   1350
   End
   Begin VB.Label lblBackGround
      Alignment       =   2  'Center
      Caption         =   "Background"
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   480
      TabIndex        =   8
      Top             =   240
      Width           =   1020
   End
   Begin VB.Label lblMask
      Alignment       =   2  'Center
      Caption         =   "Mask"
      Height          =   285
      Left            =   510
      TabIndex        =   7
      Top             =   2550
      Width           =   1050
   End
   Begin VB.Label lblForeGround
      Alignment       =   2  'Center
      Caption         =   "Foreground"
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   2790
      TabIndex        =   6
      Top             =   240
      Width           =   1020
   End
Attribute VB_Name = "frmPicMask"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' PicMask.frm
' By Herman Liu
' If you have problems in grasping the basics of mask and raster operations, or
' find it difficult to digest the materials you have tried hard to obtain, it
' is not yourself to blame. Most of the materials around on these topics are either
' too "dry" or only "half-baked" for non-professionals, some are even obsolete.
' This code attempts to knit together the essential points pertaining to the
' inter-relationship of mask, transparency and raster operations, in a live example.
' Hope it will be of help to you.
' The exercise is to overlay a given picture onto another; the latter being the
' background of the new picture.  Two different approaches are presented; it is up
' to you to choose which one to follow (or both).
Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, _
    ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
    ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
'--------------------------------------------------------
' The following APIs are required only when Method 2 is opted
'--------------------------------------------------------
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, _
    ByVal crColor As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, _
    ByVal y As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, _
    ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
    ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight _
    As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Dim picW As Long
Dim picH As Long
Dim mresult

Private Sub Form_Load()
    Me.Move 0, 0
    picBackgd.AutoRedraw = True
    picBackgd.AutoSize = True
    picFgd.AutoRedraw = True
    picFgd.AutoSize = False
    picMask.AutoRedraw = True
    picMask.AutoSize = False
    picProduct.AutoRedraw = True
    picProduct.AutoSize = True
      ' For use if Method 1 only
    picReverseMaskedFgd.AutoRedraw = True
    picReverseMaskedFgd.AutoSize = False
    picReversedMask.AutoRedraw = True
    picReversedMask.AutoSize = False
      ' For use if Method 2 only (Not shared, for clarity purposes)
    picUnblockedFgd.AutoRedraw = True
    picUnblockedFgd.AutoSize = False
    picTransparent.AutoRedraw = True
    picTransparent.AutoSize = False
    picBackgd.Width = picFgd.Width
    picBackgd.Height = picFgd.Height
    picMask.Width = picFgd.Width
    picMask.Height = picFgd.Height
    picProduct.Width = picFgd.Width
    picProduct.Height = picFgd.Height
    picReverseMaskedFgd.Height = picFgd.Height
    picReverseMaskedFgd.Width = picFgd.Width
    picReversedMask.Height = picFgd.Height
    picReversedMask.Width = picFgd.Width
    picUnblockedFgd.Width = picFgd.Width
    picUnblockedFgd.Height = picFgd.Height
    picTransparent.Width = picFgd.Width
    picTransparent.Height = picFgd.Height
      ' Align
    picFgd.Top = picBackgd.Top
    picProduct.Top = picBackgd.Top
    picUnblockedFgd.Top = picMask.Top
    picReverseMaskedFgd.Top = picMask.Top
    picTransparent.Top = picMask.Top
    picReversedMask.Top = picMask.Top
    picMask.Left = picBackgd.Left
    picUnblockedFgd.Left = picFgd.Left
    picReverseMaskedFgd.Left = picFgd.Left
    picTransparent.Left = picProduct.Left
    picReversedMask.Left = picProduct.Left
      ' For convenience
    picW = picBackgd.ScaleWidth
    picH = picBackgd.ScaleHeight
      ' Default these first. The following two labels
      ' are shared by Method 1 and 2.
    lblMask.Caption = ""
    lblReverseMaskedFgd.Caption = ""
    lblReversedMask.Caption = ""
    picUnblockedFgd.Visible = False
    picTransparent.Visible = False
End Sub
' To blacken the non-white area
Sub CreateMask(inPic As PictureBox, inColorToUse)
    On Error Resume Next
    Dim mTranspColor As Long
    Dim i, j
    mTranspColor = inPic.Point(1, 1)
        ' See if existing background is fully covered by
        ' some foreground color which is to serve as
        ' background visually. We are to use image of
        ' picBackgd as the background.
    If mTranspColor <> inColorToUse Then
        For j = 0 To picH + 1
            For i = 0 To picW + 1
                If inPic.Point(j, i) = mTranspColor Then
                    inPic.PSet (j, i), vbWhite
                End If
            Next i
            DoEvents
        Next j
    End If
    For j = 0 To picH + 1
        For i = 0 To picW + 1
            If inPic.Point(j, i) <> vbWhite Then
                inPic.PSet (j, i), inColorToUse
            End If
        Next i
        DoEvents
    Next j
End Sub
Private Sub cmdMethod1_Click()
    On Error Resume Next
    Me.MousePointer = vbHourglass
    picMask.Cls
    picMask.Picture = LoadPicture()
    picReverseMaskedFgd.Cls
    picReverseMaskedFgd.Picture = LoadPicture()
    picReversedMask.Cls
    picReversedMask.Picture = LoadPicture()
    picProduct.Cls
    picProduct.Picture = LoadPicture()
    lblMask.Caption = "Mask"
    lblReverseMaskedFgd.Caption = "Reverse-masked foreground"
    picReverseMaskedFgd.Visible = True
    picTransparent.Visible = False
    lblReversedMask.Caption = "Reversed mask"
    picReversedMask.Visible = True
    picUnblockedFgd.Visible = False
        ' (For method 1, we will superimpose on picProduct the
        ' reverse masked foreground, not the picFgd itself, hence
        ' we don't have to call doUnBlockForeGround as we do in
        ' the case of method 2)

        ' Prepare picMask (get a replica of foregound image, then mask it)
    mresult = BitBlt(picMask.hdc, 0, 0, picW, picH, _
         picFgd.hdc, 0, 0, vbSrcCopy)

     ' Do masking
    CreateMask picMask, vbBlack
         ' Background picBackgd can readily be copied onto picProduct
    BitBlt picProduct.hdc, 0, 0, picW, picH, picBackgd.hdc, 0, 0, vbSrcCopy
    picProduct.Picture = picProduct.Image
       ' Copy the mask onto the picProduct using the vbMergePaint opcode
       ' to erase pixels corresponding to black parts of the mask.
    BitBlt picProduct.hdc, 0, 0, picW, picH, picMask.hdc, 0, 0, vbMergePaint
    picProduct.Picture = picProduct.Image
    CreateReverseMaskedFgd
       ' Copy the reverse masked Fgd image onto the masked background
    BitBlt picProduct.hdc, 0, 0, picW, picH, picReverseMaskedFgd.hdc, _
          0, 0, vbSrcAnd
    picProduct.Picture = picProduct.Image
    Me.MousePointer = vbDefault
End Sub
' For creating reverse-masked foreground as an intermediary
Private Sub CreateReverseMaskedFgd()
       ' Make a reversed mask.
    BitBlt picReversedMask.hdc, 0, 0, picW, picH, picMask.hdc, 0, 0, vbNotSrcCopy
    picReversedMask.Picture = picReversedMask.Image
       ' Copy picFgd to picReverseMaskedFgd
    BitBlt picReverseMaskedFgd.hdc, 0, 0, picW, picH, picFgd.hdc, _
        0, 0, vbSrcCopy
    picReverseMaskedFgd.Picture = picReverseMaskedFgd.Image
       ' Copy the earlier reversed mask onto the picRevserseMaskedFgd
       ' using vbMergePaint opcode to erase part of the foreground
       ' which corresponds to the black parts of that reversed mask.
    BitBlt picReverseMaskedFgd.hdc, 0, 0, picW, picH, picReversedMask.hdc, _
           0, 0, vbMergePaint
    picReverseMaskedFgd.Picture = picReverseMaskedFgd.Image
End Sub
Private Sub cmdMethod2_Click()
    On Error Resume Next
    Me.MousePointer = vbHourglass
    picMask.Cls
    picMask.Picture = LoadPicture()
    picUnblockedFgd.Cls
    picUnblockedFgd.Picture = LoadPicture()
    picTransparent.Cls
    picTransparent.Picture = LoadPicture()
    picProduct.Cls
    picProduct.Picture = LoadPicture()
    lblMask.Caption = "Mask"
    lblReversedMask.Caption = "Unblocked foreground"
    picUnblockedFgd.Visible = True
    picReversedMask.Visible = False
    lblReverseMaskedFgd.Caption = "Transparent bitmap"
    picTransparent.Visible = True
    picReverseMaskedFgd.Visible = False
        ' For method 2, we have to check if entire foreground of picFgd
        ' is painted; if so change it, but reflect the change in
        ' picUnblockedFgd only (as after being made transparent it is
        ' this one to be superimposed on picProduct)
        '
        ' Make a copy of picFgd for picUnblockedFgd first
    mresult = BitBlt(picUnblockedFgd.hdc, 0, 0, picW, picH, _
         picFgd.hdc, 0, 0, vbSrcCopy)
    picUnblockedFgd.Picture = picUnblockedFgd.Image

        ' Unblock existing background as we are to use a
        ' specified background as per picBackgd.
    doUnBlockForeGround picFgd, picUnblockedFgd
        ' Use the unblocked foreground to prepare picMask (get a
        ' replica of foregound image, then mask it).
      ' Make a copy of picUnblockedFgd for its masking
    mresult = BitBlt(picMask.hdc, 0, 0, picW, picH, _
         picUnblockedFgd.hdc, 0, 0, vbSrcCopy)
      ' Do masking
    CreateMask picMask, vbBlack
    picMask.Picture = picMask.Image
         ' Background picBackgd can readily be copied onto picProduct
    BitBlt picProduct.hdc, 0, 0, picW, picH, picBackgd.hdc, _
           0, 0, vbSrcCopy
    picProduct.Picture = picProduct.Image
       ' Copy the mask onto the picProduct using the vbMergePaint opcode
       ' to erase pixels corresponding to black parts of the mask.
    BitBlt picProduct.hdc, 0, 0, picW, picH, picMask.hdc, 0, 0, vbMergePaint
    picProduct.Picture = picProduct.Image
       ' Continue with other processes
    Dim mColorAsTransparentr As Long
       ' vbWhite as it is that part of area to become transparent in this case
    mColorAsTransparentr = vbWhite
    CreateTransparent picUnblockedFgd, picTransparent, _
             mColorAsTransparentr

       ' Put the transparent picFgd on picProduct
    BitBlt picProduct.hdc, 0, 0, picW, picH, picTransparent.hdc, _
          0, 0, vbSrcAnd
    picProduct.Picture = picProduct.Image
    Me.MousePointer = vbDefault
    DoEvents
End Sub
' For creating a transparent bitmap as an intermediary
Sub CreateTransparent(inpicSrc As PictureBox, inpicDest As PictureBox, _
       inTransColor As Long)
    On Error Resume Next
    Dim mMaskDC As Long
    Dim mMaskBmp As Long
    Dim mTempMaskBMP As Long
    Dim mMonoBMP As Long
    Dim mMonoDC As Long
    Dim mTempMonoBMP As Long
    Dim mSrcHDC As Long, mDestHDC As Long
    Dim w As Long, h As Long
    w = inpicSrc.ScaleWidth
    h = inpicSrc.ScaleHeight
    mSrcHDC = inpicSrc.hdc
    mDestHDC = inpicDest.hdc
     ' Set back color of source pic and dest pic to
     ' the desired transparent color
    mresult = SetBkColor&(mSrcHDC, inTransColor)
    mresult = SetBkColor&(mDestHDC, inTransColor)
    ' Create a mask DC compatible with dest image
    mMaskDC = CreateCompatibleDC(mDestHDC)
    ' and a bitmap of its size
    mMaskBmp = CreateCompatibleBitmap(mDestHDC, w, h)
    ' Move that bitmap into mMaskDC
    mTempMaskBMP = SelectObject(mMaskDC, mMaskBmp)
    ' Meanwhile create another DC for mono bitmap by
    '  setting nPlane and nbitCount both to 1.
    mMonoDC = CreateCompatibleDC(mDestHDC)
    '  and its bitmap, a mono one.
    mMonoBMP = CreateBitmap(w, h, 1, 1, 0)
    mTempMonoBMP = SelectObject(mMonoDC, mMonoBMP)
    ' Copy source image to mMonoDC
    mresult = BitBlt(mMonoDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcCopy)

    ' Copy the mMonoDC into mMaskDC
    mresult = BitBlt(mMaskDC, 0, 0, w, h, mMonoDC, 0, 0, vbSrcCopy)
    'We don't need mMonoBMP any longer
    mMonoBMP = SelectObject(mMonoDC, mTempMonoBMP)
    mresult = DeleteObject(mMonoBMP)
    mresult = DeleteDC(mMonoDC)
    'Now copy source image to dest image with XOR
    mresult = BitBlt(mDestHDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcInvert)
    'Copy the mMaskDC to dest image with AND
    mresult = BitBlt(mDestHDC, 0, 0, w, h, mMaskDC, 0, 0, vbSrcAnd)
    'Copy source image to dest image with XOR
    BitBlt mDestHDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcInvert
    'Picture is there to stay
    inpicDest.Picture = inpicDest.Image

    ' We don't need mask DC and bitmap.
    mMaskBmp = SelectObject(mMaskDC, mTempMaskBMP)
    mresult = DeleteObject(mMaskBmp)
    mresult = DeleteDC(mMaskDC)
End Sub
' Called only if Method 2 is deployed.
Private Sub doUnBlockForeGround(inPic1 As PictureBox, inPic2 As PictureBox)
    Dim mTranspColor
    Dim i, j
    mTranspColor = inPic1.Point(1, 1)
    If mTranspColor <> vbWhite Then
        For j = 0 To picH + 1
            For i = 0 To picW + 1
                If inPic1.Point(j, i) = mTranspColor Then
                      ' We keep inPic1 as it is, but change inPic2
                      ' we are to use inPic2 if Method 2 is deployed.
                    inPic2.PSet (j, i), vbWhite
                End If
            Next i
        Next j
        DoEvents                    ' See something going on
    End If
End Sub
Private Sub cmdClear_Click()
    picMask.Cls
    picMask.Picture = LoadPicture()
    picReverseMaskedFgd.Cls
    picReverseMaskedFgd.Picture = LoadPicture()
    picReversedMask.Cls
    picReversedMask.Picture = LoadPicture()
    picProduct.Cls
    picProduct.Picture = LoadPicture()
    picUnblockedFgd.Cls
    picUnblockedFgd.Picture = LoadPicture()
    picTransparent.Cls
    picTransparent.Picture = LoadPicture()
    lblMask.Caption = ""
    lblReverseMaskedFgd.Caption = ""
    picReverseMaskedFgd.Visible = True
    picTransparent.Visible = False
    lblReversedMask.Caption = ""
    picReversedMask.Visible = True
    picUnblockedFgd.Visible = False
End Sub
Private Sub cmdExit_Click()
    Unload Me
End Sub